home *** CD-ROM | disk | FTP | other *** search
/ Aminet 16 / Aminet 16 (1996)(GTI - Schatztruhe)[!][Dec 1996].iso / Aminet / dev / src / wangisrc.lha / wangi / z / Publican / Publican.PAS < prev   
Pascal/Delphi Source File  |  1995-07-11  |  12KB  |  491 lines
  1. USES Intuition, Exec, Amiga, AmigaDOS, Graphics, Gadtools, Utility;
  2.  
  3. {$F-,I-,R-,S-,V-,M 4,1,2,15}
  4.  
  5. TYPE
  6.     pPSNode = ^tPSNode;
  7.     tPSNode = Record
  8.         ps_succ, ps_pred : pPSNode;
  9.         Pad1 : byte;
  10.         Pad2 : shortint;
  11.         ps_Name : STRPTR;
  12.     end;
  13.  
  14. VAR
  15.     node       : pPSNode;
  16.     RDArgs     : pRDArgs;
  17.     popset, 
  18.     shanset, OK: Boolean;
  19.     buf, front : string[140];
  20.     
  21. Const 
  22.     Head       : String[10]    = 'Publican'#0;
  23.     Version    : String[24] = 'Publican 1.6 (01.10.94)'#0;
  24.     ScreenList : pList = NIL;
  25.     remK       : pRemember = NIL;
  26.     
  27. function CStrConstPtrAR(rk : ppRemember; s : String) : STRPTR;
  28.  
  29. var  p : STRPTR;
  30. begin
  31.   s := s + #0;                                    { Make "C" string }
  32.   p := AllocRemember(rk, length(s), MEMF_CLEAR);  { Get some mem for it }
  33.   move(s[1], p^, length(s));                      { Move s into newly alloc'd mem }
  34.   CStrConstPtrAR := p                               { Return the pointer }
  35. end;
  36.  
  37.  
  38.  
  39. Function GetPubScreenList(VAR rk : pRemember; VAR Front : String;
  40.                                                     VAR n : Integer) : pList;
  41.  
  42. VAR
  43.     node    : pPSNode;
  44.     pubnode : pPubScreenNode;
  45.     PS_List : pList;
  46.     OutList : pList;
  47.     scrlock : LONG;
  48.     n2      : Integer;
  49.     def, buf: String;
  50.  
  51. begin
  52.     Front := '';
  53.     n2 := 0;
  54.     GetDefaultPubScreen(@buf);
  55.     def := PtrToPas(@buf);
  56.     
  57.     OutList := AllocRemember(@rk, sizeof(tList), MEMF_CLEAR);
  58.     if OutList <> NIL then begin
  59.         NewList(OutList);
  60.         PS_List := LockPubScreenList;
  61.         pubnode := pPubScreenNode(PS_List^.lh_Head);
  62.         While pubnode^.psn_Node.ln_Succ <> NIL Do Begin
  63.             node := AllocRemember(@rk, Sizeof(tPSNode), MEMF_CLEAR);
  64.             if node <> NIL then begin
  65.                 node^.ps_Name := CStrConstPtrAR(@rk, PtrToPas(pubnode^.psn_Node.ln_Name));
  66.                 AddTail(OutList,pNode(node));
  67.             end;
  68.             if PtrToPas(pubnode^.psn_Node.ln_Name) = def then
  69.                 n := n2;
  70.                 
  71.             ScrLock := LockIBase(0);
  72.             if pubnode^.psn_Screen = IntuitionBase^.ActiveScreen then
  73.                 Front := PtrToPas(pubnode^.psn_Node.ln_Name);
  74.             UnLockIBase(ScrLock);
  75.             
  76.             inc(n2);
  77.             pubnode := pPubScreenNode(pubnode^.psn_Node.ln_Succ);
  78.         End;
  79.         UnLockPubScreenList;
  80.     end;
  81.     GetPubScreenList := OutList;
  82. end;
  83.  
  84.  
  85.  
  86. Procedure FreePubScreenList(VAR List : pList; VAR rk : pRemember);
  87.  
  88. begin
  89.     If rk <> NIL then
  90.         FreeRemember(@rk, True);
  91.     rk := NIL;
  92.     List := NIL;
  93. end;
  94.  
  95. Procedure GetPubFlags(VAR pop, shan : Boolean);
  96.  
  97. VAR
  98.     Oldmodes : LONG;
  99.     
  100. begin
  101.     oldmodes := SetPubScreenModes(0);
  102.     if oldmodes and SHANGHAI <> 0 then 
  103.         shan := true
  104.     else
  105.         shan := false;
  106.     if oldmodes and POPPUBSCREEN <> 0 then
  107.         pop := true
  108.     else
  109.         pop := false;
  110.     oldmodes := SetPubScreenModes(oldmodes);
  111. end;
  112.  
  113. Procedure TogglePubFlags(pop, shan : Boolean);
  114.  
  115. VAR
  116.     flags : LONG;
  117.     
  118. begin
  119.     flags := SetPubScreenModes(0);
  120.     if shan then
  121.         flags := flags xor SHANGHAI;
  122.     if pop then 
  123.         flags := flags xor POPPUBSCREEN;
  124.     flags := SetPubScreenModes(flags);
  125. end;
  126.  
  127. Procedure SetPubFlags(pop, shan : Boolean);
  128.  
  129. VAR
  130.     flags : LONG;
  131.     
  132. begin
  133.     flags := SetPubScreenModes(0);
  134.     if shan then
  135.         flags := flags|SHANGHAI
  136.     else
  137.         flags := flags and (NOT SHANGHAI);
  138.     if pop then 
  139.         flags := flags|POPPUBSCREEN
  140.     else
  141.         flags := flags and (NOT POPPUBSCREEN);
  142.     flags := SetPubScreenModes(flags);
  143. end;
  144.     
  145. Procedure WBMain;
  146.  
  147. VAR
  148.     t           : Array[1..21] of LONG;
  149.     sampTxt     : tIntuiText;
  150.     screendef   : pScreen;
  151.     pgad, glist, 
  152.     gadcode,
  153.     LVgad,
  154.     POPgad,
  155.     SHANgad     : pGadget;
  156.     vi          : pointer;
  157.     My_Font     : pTextAttr;
  158.     gadgetFlags : tNewGadget;
  159.     win         : pWindow;
  160.     TBS, gadW, 
  161.     selected, y : Integer;
  162.     ExitFlag    : Boolean;
  163.     dummy, 
  164.     msgclass, 
  165.     msgcode     : LONG;
  166.     message     : pIntuiMessage;
  167.     Node        : pPSNode;
  168.     numticks    : 0..21;
  169.     
  170.     
  171.  
  172. CONST   {                          |         |         |         |         |}
  173.     LVTxt : String[26]   = 'Available Public Screens'#0;
  174.     PopTxt : String[38]  = 'Pop public screens to front'#0;
  175.     shanTxt : String[42] = 'Shanghai windows to default public screen'#0;
  176.     titTxt : String[28]  = 'Publican 1.5 ©Lee Kindness.'#0;
  177.     LV = 1;
  178.     POP = 2;
  179.     SHAN = 3;
  180.     Zoom : Array[0..3] of Integer = (-1,-1,150,0);
  181.     
  182.     
  183. Procedure UpDateWin;
  184.  
  185. begin
  186.     { detach list }
  187.     t[1] := GTLV_Labels;
  188.     t[2] := -1;
  189.     t[3] := TAG_END;
  190.     GT_SetGadgetAttrsA(LVgad, win, NIL, @T);
  191.  
  192.     FreePubScreenList(ScreenList, remk);
  193.     { get new list of public screens }
  194.     ScreenList := GetPubScreenList(remk, front, selected);
  195.  
  196.     { update LV }
  197.     t[1] := GTLV_Labels;
  198.     t[2] := LONG(ScreenList);
  199.     t[3] := GTLV_Selected;
  200.     t[4] := selected;
  201.     t[5] := TAG_END;
  202.     GT_SetGadgetAttrsA(LVgad, win, NIL, @T);
  203.  
  204.     { get pub screen flags }
  205.     GetPubFlags(popset, shanset);
  206.                                             
  207.     { update CB gadgets }
  208.     t[1] := GTCB_Checked;
  209.     t[2] := ord(popset);
  210.     t[3] := TAG_END;
  211.     GT_SetGadgetAttrsA(POPgad, win, NIL, @T);
  212.     t[2] := ord(shanset);
  213.     GT_SetGadgetAttrsA(SHANgad, win, NIL, @T);
  214. end;
  215.                                         
  216.                                         
  217. begin
  218.     glist := NIL;
  219.     GadToolsBase := OpenLibrary('gadtools.library',36);
  220.     if (GadToolsBase <> NIL) then begin
  221.         ScreenList := GetPubScreenList(remk, front, selected);
  222.         GetPubFlags(popset, shanset);
  223.         
  224.         ScreenDef := LockPubScreen(NIL);
  225.  
  226.         { Get visual info and create context }
  227.         vi := GetVisualInfoA(screendef, NIL);
  228.         If vi <> NIL Then begin
  229.             pGad := CreateContext(@glist);
  230.             If pGad <> NIL Then begin
  231.                 
  232.                 TBS := screendef^.WBorTop + (screendef^.Font^.ta_YSize + 1);
  233.                 Zoom[3] := TBS;
  234.                 My_Font := Screendef^.Font;
  235.                 Samptxt.ITextFont := My_Font;
  236.                 Samptxt.IText := @shantxt[1];
  237.                 gadW := IntuiTextLength(@Samptxt)+((TBS+1)*2)+16;
  238.             
  239.                 t[1] := GTLV_Labels;
  240.                 t[2] := LONG(ScreenList);
  241.                 t[3] := GTLV_Selected;
  242.                 t[4] := selected;
  243.                 t[5] := GTLV_ShowSelected;
  244.                 t[6] := 0;
  245.                 t[7] := TAG_END;
  246.  
  247.                 With GadgetFlags Do Begin
  248.                     ng_TextAttr   := My_Font;
  249.                     ng_LeftEdge   := Screendef^.WBorLeft+8;
  250.                     ng_TopEdge    := (TBS*2)+6;
  251.                     ng_Width      := gadW;
  252.                     ng_Height     := (TBS+1)*4;
  253.                     ng_GadgetText := @LVTxt[1];
  254.                     ng_VisualInfo := vi;
  255.                     ng_GadgetID   := LV;
  256.                     ng_Flags      := PLACETEXT_ABOVE;
  257.                 End;
  258.                 { create gadgets }
  259.                 LVgad := CreateGadgetA(LISTVIEW_KIND, pgad, @Gadgetflags, @t);
  260.                 
  261.                 t[1] := GTCB_Checked;
  262.                 t[2] := ord(popset);
  263.                 t[3] := $80080044; { GTCB_Scaled }
  264.                 t[4] := True_;
  265.                 t[5] := TAG_END;
  266.  
  267.                 With GadgetFlags Do Begin
  268.                     if GadToolsBase^.lib_Version >= 39 then
  269.                         ng_TopEdge    := LVgad^.TopEdge+LVgad^.Height+4
  270.                     else
  271.                         ng_TopEdge  := LVgad^.TopEdge+LVgad^.Height+6+TBS;
  272.                     ng_Width      := (TBS+1)*2;
  273.                     ng_Height     := TBS+1;
  274.                     ng_GadgetText := @PopTxt[1];
  275.                     ng_GadgetID   := POP;
  276.                     ng_Flags      := PLACETEXT_RIGHT;
  277.                 End;
  278.                 { create gadgets }
  279.                 POPgad := CreateGadgetA(CHECKBOX_KIND, LVgad, @Gadgetflags, @t);
  280.                 
  281.                 t[2] := ord(shanset);
  282.                 
  283.                 With GadgetFlags Do Begin
  284.                     ng_TopEdge    := ng_TopEdge+ng_Height+4;
  285.                     ng_GadgetText := @shanTxt[1];
  286.                     ng_GadgetID   := SHAN;
  287.                 End;
  288.                 { create gadgets }
  289.                 SHANgad := CreateGadgetA(CHECKBOX_KIND, POPgad, @Gadgetflags, @t);
  290.                 
  291.                                 
  292.                 t[1]  := WA_Left;
  293.                 t[2]  := 0;
  294.                 t[3]  := WA_Top;
  295.                 t[4]  := TBS;
  296.                 t[5]  := WA_IDCMP;
  297.                 t[6]  := IDCMP_INTUITICKS|CHECKBOXIDCMP|BUTTONIDCMP|LISTVIEWIDCMP|
  298.                                     IDCMP_MOUSEBUTTONS|IDCMP_CLOSEWINDOW|IDCMP_REFRESHWINDOW;
  299.                 t[7]  := WA_Gadgets;
  300.                 t[8]  := LONG(glist);
  301.                 t[9]  := WA_ScreenTitle;
  302.                 t[10] := LONG(@titTxt[1]);
  303.                 t[11] := WA_Title;
  304.                 t[12] := LONG(@titTxt[1]);
  305.                 t[13] := WA_InnerWidth;
  306.                 t[14] := GadW+16;
  307.                 t[15] := WA_Height;
  308.                 t[16] := shangad^.TopEdge+shangad^.Height+8;
  309.                 t[17] := WA_Flags;
  310.                 t[18] := WFLG_DRAGBAR|WFLG_SIMPLE_REFRESH|WFLG_ACTIVATE|WFLG_RMBTRAP|
  311.                                     WFLG_DEPTHGADGET|WFLG_CLOSEGADGET;
  312.                 t[19] := WA_Zoom;
  313.                 t[20] := LONG(@Zoom);
  314.                 t[21] := TAG_END;
  315.                 
  316.                 win := OpenWindowTagList(NIL, @t);
  317.                 if win <> NIL then begin
  318.                     GT_RefreshWindow(win, NIL);
  319.                     
  320.                     numticks := 1;
  321.                     exitflag := false;
  322.                     While Not exitflag Do Begin
  323.                         dummy    := Wait(BitMask(Win^.UserPort^.MP_SIGBIT));
  324.                         message  := GT_GetIMsg(Win^.userPort);
  325.                         while message <> NIL do begin
  326.                             MsgClass := message^.Class;
  327.                             MsgCode  := message^.Code;
  328.                             if MsgClass = IDCMP_GADGETUP then begin
  329.                                 GadCode  := pGadget(message^.IAddress);
  330.                             end;
  331.                             GT_ReplyIMsg(message);
  332.                             Case MsgClass Of
  333.                             
  334.                                 IDCMP_MOUSEBUTTONS : Begin
  335.                                     if MsgCode = MENUUP then
  336.                                         ZipWindow(Win);
  337.                                 End;
  338.                                 
  339.                                 IDCMP_INTUITICKS : Begin
  340.                                     inc(numTicks);
  341.                                     if numticks = 20 then begin
  342.                                         UpDateWin;
  343.                                         numticks := 1;
  344.                                     End;
  345.                                 End;
  346.                             
  347.                                 IDCMP_CLOSEWINDOW : ExitFlag := True;
  348.                             
  349.                                 IDCMP_REFRESHWINDOW : begin
  350.                                     GT_BeginRefresh(Win);
  351.                                     GT_EndRefresh(Win, True);
  352.                                 end;
  353.                                 
  354.                                 IDCMP_GADGETUP : Begin       
  355.                                     Case gadcode^.GadgetID Of
  356.                                         LV : begin
  357.                                             Node := pPSNode(ScreenList^.lh_Head);
  358.                                             For y := 1 to msgcode do
  359.                                             Node := pPSNode(Node^.ps_Succ);
  360.                                             SetDefaultPubScreen(node^.ps_Name);
  361.                                         end;
  362.                                         POP : begin
  363.                                             if gadcode^.Flags and GFLG_SELECTED <> 0 then 
  364.                                                 popset := True
  365.                                             else
  366.                                                 popset := False;
  367.                                             SetPubFlags(popset, shanset);
  368.                                         end;
  369.                                         SHAN : begin
  370.                                             if gadcode^.Flags and GFLG_SELECTED <> 0 then 
  371.                                                 shanset := True
  372.                                             else
  373.                                                 shanset := False;
  374.                                             SetPubFlags(popset, shanset);
  375.                                         end;   
  376.                                     end;
  377.                                 end; 
  378.                             End; {case}
  379.                             message  := GT_GetIMsg(Win^.userPort);
  380.                         end;
  381.                     End; {while}
  382.                     CloseWindow(win);
  383.                 end;
  384.                 FreeGadgets(glist);
  385.             end;
  386.             FreeVisualInfo(vi);
  387.         end;
  388.         UnlockPubScreen(NIL, screendef);
  389.         FreePubScreenList(ScreenList, remk);
  390.         CloseLibrary(pLibrary(GadToolsBase));
  391.     end;
  392. end;
  393.  
  394.     
  395. Function CLIMain : Integer;
  396.     
  397. CONST
  398.     RD_Array : Array[0..6] of LongInt = (0);
  399.     POPPUB = 0;
  400.     SHANG  = 1;
  401.     LIST   = 2;
  402.     EVAR   = 3;
  403.     GLOBAL = 4;
  404.     GUI    = 5;
  405.     PUBSCR = 6;
  406.     err : ShortInt = 0;
  407.  
  408. Var 
  409.     junk : integer;
  410.     Template : String;
  411.     Flags : LONG;
  412.     
  413.     
  414. Begin
  415.     template := 
  416. 'P=POPPUBSCREEN/S,S=SHANGHAI/S,L=LIST/S,VAR=VARIABLE/K,GLOBAL/S,GUI/S,DPS=PUBSCREEN=PUBSCR/K/F'#0;
  417.     RDArgs := ReadArgs(@Template[1],@RD_Array, NIL);
  418.     If RDArgs <> NIL then begin
  419.         ScreenList := GetPubScreenList(remk, front, junk);
  420.                 
  421.         { set public screen flags }
  422.         TogglePubFlags(Boolean(RD_Array[POPPUB]), Boolean(RD_Array[SHANG]));
  423.                 
  424.         { set default public screen }
  425.         if RD_Array[PUBSCR] <> 0 then
  426.             SetDefaultPubScreen(STRPTR(RD_Array[PUBSCR]));
  427.                     
  428.         { show pubscreen list and flags }
  429.         if Boolean(RD_Array[LIST]) then begin
  430.             Writeln('Public screen list:');
  431.             node := pPSNode(ScreenList^.lh_Head);
  432.             While Node^.ps_Succ <> NIL do begin
  433.                 Writeln(PtrToPas(Node^.ps_Name));
  434.                 Node := node^.ps_succ;
  435.             end;
  436.             Writeln;
  437.             Writeln('Default public screen:');
  438.             GetDefaultPubScreen(@buf);
  439.             Writeln(PtrToPas(@buf));
  440.             if front <> '' then begin
  441.                 Writeln;
  442.                 Writeln('Front public screen:');
  443.                 Writeln(front);
  444.             End;
  445.             Writeln;
  446.             Writeln('Public screen flags:');
  447.             GetPubFlags(popset, shanset);
  448.             Writeln('POPPUBSCREEN : ',popset);
  449.             Writeln('SHANGHAI : ',shanset);
  450.         end;
  451.         
  452.         if RD_Array[EVAR] <> 0 then begin
  453.             if RD_Array[GLOBAL] <> 0 then
  454.                 flags := GVF_GLOBAL_ONLY
  455.             else
  456.                 flags := GVF_LOCAL_ONLY;
  457.             OK := SetVar(STRPTR(RD_Array[EVAR]), @Front[1], length(front), flags);
  458.         End;
  459.                         
  460.         if (RD_Array[0] = 0) and (RD_Array[1] = 0) and (RD_Array[2] = 0) 
  461.         and (RD_Array[3] = 0) and (RD_Array[4] = 0) and (RD_Array[5] = 0) 
  462.         and (RD_Array[6] = 0) then
  463.             Write(front);
  464.                 
  465.         { free memory allocated }
  466.         FreePubScreenList(ScreenList, remk);
  467.         
  468.         { if GUI switch specified then open window }
  469.         if RD_Array[GUI] <> 0 then
  470.             WBMain;
  471.  
  472.         FreeArgs(RDArgs);
  473.     end;
  474.     CLIMain := IOErr;
  475. end;                
  476.                     
  477. begin
  478.     IntuitionBase := pIntuitionBase(OpenLibrary('intuition.library',36));
  479.     if (IntuitionBase <> NIL) then begin
  480.         If CmdLinePtr.Len >= 1 then begin
  481.             { from CLI }
  482.             if pDosLibrary(DOSBase)^.dl_Lib.lib_Version >= 36 then
  483.                 OK := PrintFault(CLIMain, @Head[1]);
  484.         end else
  485.             { from WB }
  486.             WBMain;
  487.         CloseLibrary(pLibrary(IntuitionBase));
  488.     end;
  489. end.
  490.                 
  491.